home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-04 / win-fort.zip / FWCLOCK.FOR < prev    next >
Text File  |  1991-11-09  |  5KB  |  138 lines
  1. $DEFINE KERNEL
  2. $DEFINE USER
  3. $DEFINE GDI
  4. $DEFINE MSG
  5. $DEFINE MENUS
  6. $DEFINE SYSMETRICS
  7. $DEFINE WINMESSAGES
  8. $DEFINE WINSTYLES
  9. $DEFINE RESOURCE
  10.       INCLUDE 'WINDOWS.FI'
  11. C
  12. C Author       : Kevin B Black
  13. C Date written : 23-Oct-1991
  14. C Abstract     :
  15. C
  16. C FORTRAN WINDOWS 3.0 DIGITAL/ANALOGUE CLOCK
  17. C
  18. C WinMain       - Main Windows 3.0 function for FWCLOCK
  19. C
  20.       FUNCTION WinMain[PASCAL,FAR] (hInstance,hPrevInstance,
  21.      *                                               IpCmdLine,nCmdShow)
  22.       IMPLICIT NONE
  23.  
  24.       INTEGER*2 WinMain
  25.       INTEGER*2 hInstance     ! current instance
  26.       INTEGER*2 hPrevInstance ! previous instance
  27.       INTEGER*4 IpCmdLine     ! command line
  28.       INTEGER*2 nCmdShow      ! show-window type (open/icon)
  29.  
  30.       INCLUDE 'WINDOWS.FD'
  31.       INTEGER*2 InitFWClock  [EXTERN,FAR]
  32.       INCLUDE 'FWCLOCK.FD'
  33.  
  34.       INTEGER*2 JUNK          ! Dummy argument for 100ths seconds for GETTIM
  35.  
  36.       RECORD /MSG/ Wmsg       ! message
  37.  
  38.       IF(hPrevInstance.EQ.0)THEN                 ! Other instances of app running?
  39.      IF(InitFWClock(hInstance).EQ.0)THEN     ! Initialize shared things
  40.         WinMain=0                            ! Exits if unable to initialize
  41.         RETURN
  42.      ENDIF
  43.       ENDIF
  44. C
  45. C Perform initializations that apply to this specific instance
  46. C
  47.       HINST=HINSTANCE
  48. c      IMANICON=.FALSE.
  49. C
  50. C Determine the display device size and its aspect ratio
  51. C
  52.       FWCPS.HDC=GetDC(NULL) ! Get device context
  53.       DWIDTH=GetDeviceCaps(FWCPS.HDC,VERTRES)
  54.       DHEIGHT=GetDeviceCaps(FWCPS.HDC,HORZRES)
  55.       HASPECT=(DHEIGHT*1000/(GetDeviceCaps(FWCPS.HDC,HORZSIZE)*10)+5)/10
  56.       VASPECT=(DWIDTH*1000/(GetDeviceCaps(FWCPS.HDC,VERTSIZE)*10)+5)/10
  57.       VARATIO=FLOAT(VASPECT)/FLOAT(HASPECT)
  58.       WSTATUS=ReleaseDC(NULL,FWCPS.HDC)
  59. C
  60. C Determine height and width to which the clock window is to be set, the
  61. C various bit around the work area are added on to make the window the
  62. C appropriate size (the work area is then a square)
  63. C
  64.       WWIDTH=DWIDTH/2+
  65.      *        GetSystemMetrics(SM_CXFRAME)*2
  66.       WHEIGHT=WWIDTH*VASPECT/HASPECT+
  67.      *        GetSystemMetrics(SM_CYCAPTION)+
  68.      *        GetSystemMetrics(SM_CYFRAME)*2
  69.       RCLOCK.TOP=1
  70.       RCLOCK.LEFT=1
  71.       RCLOCK.BOTTOM=WHEIGHT
  72.       RCLOCK.RIGHT=WWIDTH
  73. C
  74. C Create the main FWClock window and get its handle.
  75. C
  76.       HWND=CreateWindow(
  77.      *        'FWClockWClass'C,              ! Window class
  78.      *        'FWClock'C,                    ! Text for window title bar
  79.      *        WS_OVERLAPPEDWINDOW,           ! Window style
  80.      *        CW_USEDEFAULT,                 ! Default horizontal position
  81.      *        CW_USEDEFAULT,                 ! Default vertical position
  82.      *        WWIDTH,                        ! Default width
  83.      *        WHEIGHT,                       ! Default height
  84.      *        NULL,                          ! No parent
  85.      *        NULL,                          ! Use the window class menu
  86.      *        hInstance,                     ! This instance owns this window
  87.      *        NULLSTR)                       ! Pointer not needed
  88. C
  89. C Read user selectable functions from profile file and check menu items if
  90. C enabled
  91. C
  92.       SECONDSICON=0.NE.GetPrivateProfileInt('FWClock'C,'SecondsInIcon'C,
  93.      *                                      0,'FWCLOCK.INI'C)
  94.       IF(SECONDSICON)WSTATUS=CheckMenuItem(GetMenu(hWnd),
  95.      *                                       IDM_SECONDSICON,MF_CHECKED)
  96.       SOLIDHANDS=0.NE.GetPrivateProfileInt('FWClock'C,'SolidHands'C,
  97.      *                                      0,'FWCLOCK.INI'C)
  98.       IF(SOLIDHANDS)WSTATUS=CheckMenuItem(GetMenu(hWnd),
  99.      *                                        IDM_SOLIDHANDS,MF_CHECKED)
  100.       CHIMES=0.NE.GetPrivateProfileInt('FWClock'C,'Chimes'C,
  101.      *                                      0,'FWCLOCK.INI'C)
  102.       IF(CHIMES)WSTATUS=CheckMenuItem(GetMenu(hWnd),
  103.      *                                            IDM_CHIMES,MF_CHECKED)
  104. C
  105. C Get the current time, wait until the seconds change.
  106. C
  107.       CALL GETTIM(HOURS,MINS,SECS,JUNK)
  108.       CALL GETTIM(OHOURS,OMINS,OSECS,JUNK)
  109.       DO WHILE (HOURS.EQ.OHOURS.AND.MINS.EQ.OMINS.AND.SECS.EQ.OSECS)
  110.          CALL GETTIM(OHOURS,OMINS,OSECS,JUNK)
  111.       ENDDO
  112. C
  113. C Create general tools
  114. C
  115.       CALL TOOL_UP
  116. C
  117. C Start a timer for a open window every 200 milliseconds
  118. C
  119.       IF(SetTimer(hWnd,MYTIMER,200,0).EQ.0)THEN
  120.          CALL FatalAppExit(0,'FWClock: All public timers in use'C)
  121.          STOP
  122.       ENDIF
  123. C
  124. C Show window and acquire and dispatch messages until a WM_QUIT message
  125. C is received.
  126. C
  127.       WSTATUS=ShowWindow(hWnd,nCmdShow) ! Show the window
  128.       DO WHILE (GetMessage(Wmsg,        ! message structure
  129.      *      NULL,                       ! handle of window receiving the message
  130.      *      NULL,                       ! lowest message to examine
  131.      *      NULL).NE.0)                 ! highest message to examine
  132.      WSTATUS=TranslateMessage(Wmsg) ! Translates virtual key codes
  133.      WSTATUS=DispatchMessage(Wmsg)  ! Dispatches message to window
  134.       ENDDO
  135.       WinMain=Wmsg.wParam               ! Returns the value from PostQuitMessage
  136.       RETURN
  137.       END
  138.